home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FPCDOCS.LZH / SEQREAD.SEQ < prev    next >
Text File  |  1988-09-28  |  17KB  |  427 lines
  1. \ SEQREAD.SEQ   Sequential read and load file           by Tom Zimmer
  2.  
  3. \ Link this file into the FILELIST chain.
  4.  
  5. FILES DEFINITIONS
  6.  
  7. VARIABLE SEQREAD.SEQ
  8.  
  9. FORTH DEFINITIONS
  10.  
  11. DECIMAL
  12.  
  13. \       Read sequential lines from a file, delimited by CRLF.
  14.  
  15.     0 VALUE WITHPATH            \ should the PATH be included in the file var
  16. 16384 VALUE IBLEN               \ input buffer length
  17.  
  18. \ A couple of editor words, needed to give the information editor when
  19. \ a compile error has occured.
  20.     0 VALUE BYTE|LINE
  21.     0 VALUE SCREENCHAR
  22.  
  23. \ The value of OBLEN can be reduced to 64 if you want to read lines from
  24. \ normal Forth BLOCK files. You should use BLKTOSEQ.SEQ for this though.
  25.  
  26.   255 VALUE OBLEN       \ output buffer length
  27.  
  28.     0 VALUE INSTART
  29.     0 VALUE INLENGTH
  30.     0 VALUE INBSEG              \ the input buffer
  31.    VARIABLE LISTOFF
  32.    VARIABLE TOTALLINES
  33.      CREATE OUTBUF OBLEN 1+ ALLOT \ the line output buffer
  34.  
  35. 4 B/HCB * CONSTANT MAXNEST        \  maximum of 5 hcb's
  36.  
  37.        CREATE HNDLS MAXNEST B/HCB + ALLOT
  38.         HNDLS ' SEQHANDLE >BODY !-T           \ PRESET POINTER
  39.      VARIABLE FILEPOINTER 2 allot \ most recent read
  40.      VARIABLE LOADING             \ Are we in the proccess of loading a file?
  41.             0 LOADING !-T         \ initialize to not loading.
  42.        CREATE CONHNDL B/HCB  ALLOT      1 CONHNDL >HNDLE !-T
  43.        CREATE PRNHNDL B/HCB  ALLOT      4 PRNHNDL >HNDLE !-T
  44.  
  45. : (CONSOLE)     ( C1 --- )
  46.                 OUTPAUSE
  47.                 SP@ 1 CONHNDL TYPESEG @ EXHWRITE 2DROP
  48.                 #OUT INCR ;
  49.  
  50. : (TYPE)        ( A1 N1 --- )
  51.                 OUTPAUSE 0 MAX
  52.                 PRINTING @
  53.                 IF      2DUP PRNHNDL TYPESEG @ EXHWRITE DROP
  54.                 THEN         CONHNDL TYPESEG @ EXHWRITE #OUT +! ;
  55.  
  56. : (PRINT)       ( C1 --- )
  57.                 OUTPAUSE
  58.                 SP@ 1 PRNHNDL TYPESEG @ EXHWRITE 2DROP
  59.                 #OUT INCR ;
  60.  
  61. : (EXTYPE)      ( SEG A1 N1 --- )       \ External type, from other segment
  62.                 ROT %SAVE!> TYPESEG
  63.                 TYPE
  64.                 %RESTORE> TYPESEG ;
  65.  
  66. DEFER LOADSTAT  ' NOOP IS LOADSTAT
  67.  
  68. : SEQHANDLE+        ( --- A1 )
  69.                 seqhandle b/hcb + ;
  70.  
  71. : .SEQHANDLE        ( --- )
  72.                 seqhandle count type ;
  73.  
  74. CODE CURPOINTER ( handle --- double-current )
  75.                 pop bx
  76.                 add bx, # hndloffset
  77.                 mov bx, 0 [bx]
  78.                 sub cx, cx
  79.                 mov dx, cx
  80.                 mov ax, # $4201  \ from end of file
  81.                 int $21
  82.                 push ax
  83.                 push dx
  84.                 next
  85.                 end-code
  86.  
  87. : SAVEPOINTER   ( --- )
  88.                 seqhandle curpointer inlength 0 d- filepointer 2! ;
  89.  
  90. CODE GET_ALINE  ( --- a1 )
  91.                 push es                         \ Save ES for later restoral
  92.                 mov di, ' instart >body         \ Searching from INSTART
  93.                 mov ax, # $0A                   \ Searching for a Linefeed char
  94.                 mov cx, ' inlength >body        \ for INLENGTH clipped to OBLEN
  95.                 cmp cx, ' oblen >body           \ if INLENGTH > OBLEN
  96.               > if      mov cx, ' oblen >body   \ clip search length to OBLEN
  97.                 then    mov dx, cx              \ save search length in DX
  98.           cx<>0 if      mov es, ' inbseg >body  \ searching INBSEG segment
  99.                         repnz           scasb   \ Scan for Linefeed char
  100.                 then    sub dx, cx              \ DX = length of line
  101.                 sub ' inlength >body dx         \ subtract line from remaining
  102.                 mov outbuf dl byte              \ set the length of OUTBUF
  103.                 mov bx, si                      \ save IP for later restoral
  104.                 mov si, ' instart >body         \ moving from INSTART
  105.                 add ' instart >body dx          \ set start to after line
  106.                 mov cx, dx                      \ cx = length to move
  107.                 mov di, # outbuf 1+             \ moving to OUTBUF
  108.                 mov ds, ' inbseg >body          \ from INBSEG segment
  109.                 mov ax, cs      mov es, ax      \ to CODE segment
  110.           cx<>0 if      repnz   movsb           \ move the line to OUTBUF
  111.                 then
  112.                 mov ax, cs      mov ds, ax      \ restore DS
  113.                 mov si, bx                      \ restore IP
  114.                 inc errorline word              \ bump line counter
  115.                 pop es                          \ restore ES
  116.                 mov ax, # outbuf                \ return address of buffer
  117.                 1push           end-code
  118.  
  119. : FILLBUFF      ( --- )         \ Refill the input buffer.
  120.                 inbseg instart over 0 inlength cmovel
  121.                 off> instart
  122.                 inlength iblen inlength -
  123.                 seqhandle inbseg exhread +!> inlength
  124.                 savepointer ;
  125.  
  126. CODE ?FILLBUFF  ( --- )         \ refill INBUF if needed
  127.                 cmp ' inlength >body # oblen 1+ word
  128.             u>= if      mov bx, # filepointer   \ Set BX to point to FILEPOINTER
  129.                         sub cx, cx              \ clear CX
  130.                         mov cl, outbuf          \ read byte length of OUTBUF
  131.                         add 2 [bx], cx          \ Add to 32bit contents
  132.                         adc 0 [bx], # 0
  133.                         next
  134.                 then                            \ If we got here, then
  135.                 mov ax, # ' fillbuff            \ go and re-fill the buffer
  136.                 jmp ax
  137.                 end-code
  138.  
  139. : LINEREAD      ( --- a1 )      \ read a line delimited by CRLF
  140.                 ?fillbuff       \ re-fill buffer if needed.
  141.                 get_aline ;     \ returns line including CRLF
  142.  
  143. : (DOERROR)     ( a1 n1 --- )
  144.                 2>r
  145.                 cr ." file = " .seqhandle
  146.                 ."  at Line " errorline @ u.
  147.                 cr outbuf count type cr
  148.                 >in @ 1- here c@ - 0 max
  149.                 dup %!> screenchar 0
  150.                 ?do ascii - emit loop
  151.                 ." ^-- " 2r> type space
  152.                 true %!> byte|line
  153.                 quit    ;
  154.  
  155. DEFER DOERROR   ' (DOERROR) IS DOERROR
  156.  
  157. : (?SERROR)     ( ADDR N1 BOOL --- )
  158.                 %@> loading
  159.                 if
  160.                         if      2>R sp0 @ sp! printing off loading off
  161.                                 decimal
  162.                                 ['] <run> is run
  163.                                 2R> doerror
  164.                                 quit                    \ error from disk
  165.                         else    2drop                   \ no error comes here
  166.                         then
  167.                 else    (?error)       \ command line error
  168.                 then    ;
  169.  
  170. ' (?SERROR) IS ?ERROR
  171.  
  172. : SEQUP         ( --- )
  173.                 seqhandle >hndle @ -1 >
  174.                 if      seqhandle b/hcb + dup hndls maxnest + U< 0=
  175.                         abort" Nested too deeply on FLOAD !"
  176.                         dup %!> seqhandle clr-hcb
  177.                 then    ;
  178.  
  179. : SEQINIT       ( --- )
  180.                 noop hndls %!> seqhandle
  181.                 hndls   maxnest over + swap
  182.                 do      i clr-hcb
  183.          b/hcb +loop
  184.                 iblen 0 16 um/mod nip 1+ alloc 8 = memchk nip %!> inbseg
  185.                 conhndl clr-hcb " CON." ">$ conhndl $>handle
  186.                 1 conhndl >hndle !
  187.                 prnhndl clr-hcb " PRN." ">$ prnhndl $>handle
  188.                 4 prnhndl >hndle ! ;
  189.  
  190. : IBRESET       ( --- )
  191.                 off> instart
  192.                 off> inlength ;
  193.  
  194. : SEQDOWN       ( --- )
  195.                 seqhandle hclose drop
  196.                 seqhandle clr-hcb
  197.                 seqhandle b/hcb - hndls max %!> seqhandle
  198.                 seqhandle >hndle @ -1 <>
  199.                 if      filepointer 2@
  200.                         seqhandle movepointer
  201.                         off> >in off> span off> #tib
  202.                         IBRESET
  203.                 then    ;
  204.  
  205. : CLOSE         ( --- )
  206.                 seqdown ;
  207.  
  208. : $HOPEN        ( A1 --- F1 )   \ Returns a boolean for open successful
  209.                 seqhandle hclose drop
  210.                 seqhandle $>handle
  211.                 seqhandle hopen
  212.                 ibreset ;
  213.  
  214. DEFER GETFILE       ( --- <a1> f1 )     \ return a1 filename addr and
  215.  
  216. ' FALSE IS GETFILE                      \ Default to failed
  217.  
  218. : FILE>TIB      ( a1 --- )              \ given a counted string a1, insert it
  219.                 count \ 2dup type space   \ into the Terminal Input Buffer.
  220.                 2dup true -rot over + swap
  221.                 do      i c@ ascii . =
  222.                         if      drop false leave
  223.                         then
  224.                 loop    >r dup span ! dup #tib ! >in off
  225.                 tib swap cmove r>
  226.                 if      ascii . span @ tib + c!
  227.                         span incr #tib incr
  228.                 then    ;
  229.  
  230. : GFL           ( --- )                 \ optionally prompt for file if non
  231.                                         \ is currently in the TIB.
  232.                 >in @ span @ 1- >
  233.                 if      getfile 0= abort" No filename specified"
  234.                         dup count type space
  235.                         file>tib
  236.                 then    ;
  237.  
  238. : FILE          ( --- )
  239.                 gfl bl word $hopen  abort" File open Error!"
  240.                 ." of " seqhandle endfile d. ." bytes."
  241.                 0.0 seqhandle movepointer \ reset to beginning of file
  242.                 errorline off           \ reset last line variable
  243.                 loadline off            \ reset file offset
  244.                 listoff off
  245.                 0 %!> screenchar ;
  246.  
  247. : SEEK          ( d1 --- )            \ Move the filepointer in seqhandle to the
  248.                 seqhandle movepointer ;   \ specified by d1.
  249.  
  250. 0 VALUE LISTVAR
  251.  
  252. : SHOWLINES     ( --- ) -1 %!> listvar ;
  253.  
  254. : HIDELINES     ( --- )  0 %!> listvar ;
  255.  
  256. CODE CRLF>BL'S  ( a1 --- a1 )   \ change CRLF at end of string to blanks
  257.                 pop bx          \ leaving the string address on the stack
  258.                 push bx         \ Same as -> DUP COUNT + 2- 8224 SWAP !
  259.                 mov al, 0 [bx]
  260.                 sub ah, ah
  261.                 add bx, ax
  262.                 dec bx
  263.                 mov 0 [bx], # 8224 word
  264.                 next
  265.                 end-code
  266.  
  267. CODE SETTIB     ( a1 --- )      \ Set TIB to counted string a1
  268.                 pop bx
  269.                 mov al, 0 [bx]
  270.                 inc bx
  271.                 mov 'tib bx
  272.                 sub ah, ah
  273.                 mov span ax
  274.                 mov #tib ax
  275.                 mov >in # 0
  276.                 next
  277.                 end-code
  278.  
  279. : .LOADLINE     ( a1 --- a1 )
  280.                 cr errorline @ 5 u.r space
  281.                 dup count type ;
  282.  
  283. CODE ?.LOADLINE ( a1 --- a1 )
  284.                 mov cx, ' listvar >body
  285.           cx<>0 if      mov ax, # ' .loadline   \ if LISTVAR <> zero, continue
  286.                         jmp ax
  287.                 then                            \ if LISTVAR is zero then
  288.                 next    end-code
  289.  
  290. CODE LOADLINE+SPAN      ( --- )
  291.                 mov ax, span
  292.                 add loadline ax
  293.                 next
  294.                 end-code
  295.  
  296. : FILLTIB       ( --- )
  297.                 loadline+span
  298.                 lineread crlf>bl's ?.loadline settib ;
  299.  
  300. CODE ?.STAT     ( --- )
  301.                 test errorline # 255            \ only once every 256 lines
  302.              0= if      mov ax, # ' loadstat    \ loadstat is : def
  303.                         jmp ax                  \ so we need to goto it this
  304.                 then                            \ way. Can't just do a direct
  305.                 next    end-code                \ JMP ' LOADSTAT
  306.  
  307. CODE LENGTH.CHECK ( --- F1 )
  308.                 mov ax, # true
  309.                 mov cx, ' inlength >body        \ if read length <> 0
  310.           cx<>0 if      1push                   \ then we aren't done
  311.                 then
  312.                 pop ax                          \ get a copy of line buf ptr
  313.                 push ax
  314.                 mov bx, ax
  315.                 cmp 0 [bx], # 0 byte            \ if line buffer <> 0
  316.             0<> if      1push                   \ then we aren't done
  317.                 then
  318.                 mov ax, # false
  319.                 1push   end-code                \ else we are done
  320.  
  321. : <LOAD>        ( --- )
  322.                 loadstat
  323.                 true  %save!> loading
  324.                       %save>  'tib
  325.                       %save>  >in
  326.                 false %save!> span
  327.                       %save>  errorline
  328.                 0 %!> screenchar
  329.                 begin   loadline+span
  330.                         lineread
  331.                         length.check
  332.                 while   crlf>bl's ?.loadline settib run ?.stat
  333.                 repeat  drop
  334.                 %@> errorline +!> totallines
  335.                 %restore> errorline
  336.                 %restore> span
  337.                 %@> span %!> #tib
  338.                 %restore> >in
  339.                 %restore> 'tib
  340.                 %restore> loading ;
  341.  
  342. DEFER LOADER    ' <LOAD> IS LOADER
  343.  
  344. : >LINE         ( n1 --- )
  345.                 0.0 seqhandle movepointer
  346.                 loadline off
  347.                 IBRESET
  348.                 errorline off
  349.                 1-      0 max   ?dup
  350.                 if      cr ." Stepping to line " dup 1+ u. ." .."
  351.                         0
  352.                        ?do      lineread c@ dup loadline +! 0= ?leave
  353.                         loop
  354.                 then    ;
  355.  
  356. : LOADED,       ( --- )
  357.                 %save> 'tib
  358.                 %save> >in
  359.                 %save> span  \ save state
  360.                 seqhandle count
  361.                 withpath 0=                     \ Should the PATH not be
  362.                 if                              \ included in the file VARIABLE?
  363.                         begin   2dup
  364.                                 ascii \ scan dup   \ skip the leading path
  365.                         while   2swap 2drop
  366.                                 1 -1 d+
  367.                         repeat  2drop
  368.                 then
  369.                 dup %!> span %!> #tib         \ set span and #tib
  370.                     %!> 'tib                   \ set tib to seqhandle
  371.                 off> >in                        \ clear >in
  372.                 context @ >r                    \ save current context
  373.                 current @ >r                    \  and current vocab state
  374.                 files definitions               \ select files vocabulary
  375.                 variable                        \ make the header
  376.                 r> current ! r> context !       \ restore vocabulary state
  377.                 %restore> span
  378.                 %@> span %!> #tib
  379.                 %restore> >in
  380.                 %restore> 'tib ;
  381.  
  382. : <FLOAD>       ( --- )
  383.                 span @ >r
  384.                 0 %save!> loadline
  385.                 0 %save!> errorline
  386.                 loaded,
  387.                 0.0 seqhandle movepointer
  388.                 loader
  389.                 %restore> errorline
  390.                 %restore> loadline
  391.                 r> +!> loadline ;
  392.  
  393. : FLOAD         ( --- t1 )
  394.                 sequp
  395.                 IBRESET
  396.                 %@> >in bl word c@ over %!> >in +
  397.                 0 filepointer 2@ d+ 2>r
  398.                 off> outbuf
  399.                 seqhandle !hcb
  400.                 seqhandle hopen 0<>
  401.                 if      cr ." Open error in " .seqhandle
  402.                         abort
  403.                 then    <fload>
  404.                 2r> filepointer 2!
  405.                 seqdown ;
  406.  
  407. : CHARREAD      ( --- c1 )      \ Read a character from the current file.
  408.                 loading @
  409.         if      begin   %@> >in   %@> span =    \ If nothing in line
  410.                         inlength 0> and         \ and input buf not empty
  411.                 while   ?fillbuff               \ Optionally refill buffer
  412.                         filltib                 \ refill the TIB
  413.                 repeat
  414.         then    %@> >in   incr> >in   tib + c@ ;
  415.  
  416. : OK            ( --- )         \ Load currently open file
  417.                 IBRESET
  418.                 <fload> ;
  419.  
  420.  
  421. : \S            ( n1 --- )              \ Ignore the rest of the file.
  422.                 seqhandle endfile 2drop \ Move to end of file
  423.                 loadline off
  424.                 IBRESET
  425.                 %@> span %!> >in ;      \ Ignore rest of line
  426.  
  427.